home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / c / backq.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-05-07  |  6.8 KB  |  397 lines
  1. /*
  2.  Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  3.  
  4. This file is part of GNU Common Lisp, herein referred to as GCL
  5.  
  6. GCL is free software; you can redistribute it and/or modify it under
  7. the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  8. the Free Software Foundation; either version 2, or (at your option)
  9. any later version.
  10.  
  11. GCL is distributed in the hope that it will be useful, but WITHOUT
  12. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  14. License for more details.
  15.  
  16. You should have received a copy of the GNU Library General Public License 
  17. along with GCL; see the file COPYING.  If not, write to the Free Software
  18. Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. */
  21.  
  22. #include "include.h"
  23.  
  24. #define    attach(x)    (vs_head = make_cons(x, vs_head))
  25. #define    make_list    (vs_push(Cnil), stack_cons(), stack_cons())
  26.  
  27.  
  28. #define    QUOTE    1
  29. #define    EVAL    2
  30. #define    LIST    3
  31. #define    LISTA    4
  32. #define    APPEND    5
  33. #define    NCONC    6
  34.  
  35. object siScomma;
  36. object siScomma_at;
  37. object siScomma_dot;
  38.  
  39.  
  40. object SlistA;
  41. object Sappend;
  42. object Snconc;
  43.  
  44.  
  45.  
  46. kwote_cdr()
  47. {
  48.     object x;
  49.  
  50.     x = vs_head;
  51.     if (type_of(x) == t_symbol) {
  52.         if ((enum stype)x->s.s_stype == stp_constant &&
  53.             x->s.s_dbind == x)
  54.             return;
  55.         goto KWOTE;
  56.     } else if (type_of(x) == t_cons || type_of(x) == t_vector)
  57.         goto KWOTE;
  58.     return;
  59.  
  60. KWOTE:
  61.     vs_head = make_cons(vs_head, Cnil);
  62.     vs_head = make_cons(Squote, vs_head);
  63. }
  64.  
  65. kwote_car()
  66. {
  67.     object x;
  68.  
  69.     x = vs_top[-2];
  70.     if (type_of(x) == t_symbol) {
  71.         if ((enum stype)x->s.s_stype == stp_constant &&
  72.             x->s.s_dbind == x)
  73.             return;
  74.         goto KWOTE;
  75.     } else if (type_of(x) == t_cons || type_of(x) == t_vector)
  76.         goto KWOTE;
  77.     return;
  78.  
  79. KWOTE:
  80.     vs_top[-2] = make_cons(vs_top[-2], Cnil);
  81.     vs_top[-2] = make_cons(Squote, vs_top[-2]);
  82. }
  83.  
  84. /*
  85.     Backq_cdr(x) pushes a form on vs and returns one of
  86.  
  87.         QUOTE        the form should be quoted
  88.         EVAL        the form should be evaluated
  89.         LIST        the form should be applied to LIST
  90.         LISTA        the form should be applied to LIST*
  91.         APPEND        the form should be applied to APPEND
  92.         NCONC        the form should be applied to NCONC
  93. */
  94. int
  95. backq_cdr(x)
  96. object x;
  97. {
  98.     int a, d;
  99.  
  100.     cs_check(x);
  101.  
  102.     if (type_of(x) != t_cons) {
  103.         vs_push(x);
  104.         return(QUOTE);
  105.     }
  106.     if (x->c.c_car == siScomma) {
  107.         vs_push(x->c.c_cdr);
  108.         return(EVAL);
  109.     }
  110.     if (x->c.c_car == siScomma_at || x->c.c_car == siScomma_dot)
  111.         FEerror(",@ or ,. has appeared in an illegal position.", 0);
  112.     a = backq_car(x->c.c_car);
  113.     d = backq_cdr(x->c.c_cdr);
  114.     if (d == QUOTE)
  115.         switch (a) {
  116.         case QUOTE:
  117.             vs_pop;
  118.             vs_head = x;
  119.             return(QUOTE);
  120.  
  121.         case EVAL:
  122.             if (vs_head == Cnil) {
  123.                 stack_cons();
  124.                 return(LIST);
  125.             }
  126.             if (type_of(vs_head) == t_cons &&
  127.                 vs_head->c.c_cdr == Cnil) {
  128.                 vs_head = vs_head->c.c_car;
  129.                 kwote_cdr();
  130.                 make_list;
  131.                 return(LIST);
  132.             }
  133.             kwote_cdr();
  134.             make_list;
  135.             return(LISTA);
  136.  
  137.         case APPEND:
  138.             if (vs_head == Cnil) {
  139.                 vs_pop;
  140.                 return(EVAL);
  141.             }
  142.             kwote_cdr();
  143.             make_list;
  144.             return(APPEND);
  145.  
  146.         case NCONC:
  147.             if (vs_head == Cnil) {
  148.                 vs_pop;
  149.                 return(EVAL);
  150.             }
  151.             kwote_cdr();
  152.             make_list;
  153.             return(NCONC);
  154.  
  155.         default:
  156.             error("backquote botch");
  157.         }
  158.     if (d == EVAL)
  159.         switch (a) {
  160.         case QUOTE:
  161.             kwote_car();
  162.             make_list;
  163.             return(LISTA);
  164.  
  165.         case EVAL:
  166.             make_list;
  167.             return(LISTA);
  168.  
  169.         case APPEND:
  170.             make_list;
  171.             return(APPEND);
  172.  
  173.         case NCONC:
  174.             make_list;
  175.             return(NCONC);
  176.  
  177.         default:
  178.             error("backquote botch");
  179.         }
  180.     if (a == d) {
  181.         stack_cons();
  182.         return(d);
  183.     }
  184.     switch (d) {
  185.     case LIST:
  186.         if (a == QUOTE) {
  187.             kwote_car();
  188.             stack_cons();
  189.             return(d);
  190.         }
  191.         if (a == EVAL) {
  192.             stack_cons();
  193.             return(d);
  194.         }
  195.         attach(Slist);
  196.         break;
  197.  
  198.     case LISTA:
  199.         if (a == QUOTE) {
  200.             kwote_car();
  201.             stack_cons();
  202.             return(d);
  203.         }
  204.         if (a == EVAL) {
  205.             stack_cons();
  206.             return(d);
  207.         }
  208.         attach(SlistA);
  209.         break;
  210.  
  211.     case APPEND:
  212.         attach(Sappend);
  213.         break;
  214.  
  215.     case NCONC:
  216.         attach(Snconc);
  217.         break;
  218.  
  219.     default:
  220.         error("backquote botch");
  221.     }
  222.     switch (a) {
  223.     case QUOTE:
  224.         kwote_car();
  225.         make_list;
  226.         return(LISTA);
  227.  
  228.     case EVAL:
  229.         make_list;
  230.         return(LISTA);
  231.  
  232.     case APPEND:
  233.         make_list;
  234.         return(APPEND);
  235.  
  236.     case NCONC:
  237.         make_list;
  238.         return(NCONC);
  239.  
  240.     default:
  241.         error("backquote botch");
  242.     }
  243. }
  244.  
  245. /*
  246.     Backq_car(x) pushes a form on vs and returns one of
  247.  
  248.         QUOTE        the form should be quoted
  249.         EVAL        the form should be evaluated
  250.         APPEND        the form should be appended
  251.                 into the outer form
  252.         NCONC        the form should be nconc'ed
  253.                 into the outer form
  254. */
  255. int
  256. backq_car(x)
  257. object x;
  258. {
  259.     int d;
  260.  
  261.     cs_check(x);
  262.  
  263.     if (type_of(x) != t_cons) {
  264.         vs_push(x);
  265.         return(QUOTE);
  266.     }
  267.     if (x->c.c_car == siScomma) {
  268.         vs_push(x->c.c_cdr);
  269.         return(EVAL);
  270.     }
  271.     if (x->c.c_car == siScomma_at) {
  272.         vs_push(x->c.c_cdr);
  273.         return(APPEND);
  274.     }
  275.     if (x->c.c_car == siScomma_dot) {
  276.         vs_push(x->c.c_cdr);
  277.         return(NCONC);
  278.     }
  279.     d = backq_cdr(x);
  280.     switch (d) {
  281.     case QUOTE:
  282.         return(QUOTE);
  283.  
  284.     case EVAL:
  285.         return(EVAL);
  286.  
  287.     case LIST:
  288.         attach(Slist);
  289.         break;
  290.  
  291.     case LISTA:
  292.         attach(SlistA);
  293.         break;
  294.  
  295.     case APPEND:
  296.         attach(Sappend);
  297.         break;
  298.  
  299.     case NCONC:
  300.         attach(Snconc);
  301.         break;
  302.  
  303.     default:
  304.         error("backquote botch");
  305.         }
  306.     return(EVAL);
  307. }
  308.  
  309. object
  310. backq(x)
  311. object x;
  312. {
  313.     int a;
  314.  
  315.     a = backq_car(x);
  316.     if (a == APPEND || a == NCONC)
  317.         FEerror(",@ or ,. has appeared in an illegal position.", 0);
  318.     if (a == QUOTE)
  319.         kwote_cdr();
  320.     return(vs_pop);
  321. }
  322.  
  323. Lcomma_reader()
  324. {
  325.     object in, c;
  326.  
  327.     check_arg(2);
  328.     vs_pop;
  329.     in = vs_base[0];
  330.     if (backq_level <= 0)
  331.         FEerror("A comma has appeared out of a backquote.", 0);
  332.     c = peek_char(FALSE, in);
  333.     if (c == code_char('@')) {
  334.         vs_push(siScomma_at);
  335.         read_char(in);
  336.     } else if (c == code_char('.')) {
  337.         vs_push(siScomma_dot);
  338.         read_char(in);
  339.     } else
  340.         vs_push(siScomma);
  341.     --backq_level;
  342.     vs_push(read_object(in));
  343.     backq_level++;
  344.     stack_cons();
  345.     vs_base[0] = vs_base[1];
  346.     vs_pop;
  347. }
  348.  
  349. Lbackquote_reader()
  350. {
  351.     object in;
  352.  
  353.     check_arg(2);
  354.     vs_pop;
  355.     in = vs_base[0];
  356.     backq_level++;
  357.     vs_base[0] = read_object(in);
  358.     --backq_level;
  359.     vs_base[0] = backq(vs_base[0]);
  360. }
  361.  
  362. #define    make_cf(f)    make_cfun((f), Cnil, Cnil, NULL, 0);
  363.  
  364. init_backq()
  365. {
  366.     object r;
  367.  
  368.     siScomma = make_si_ordinary(",");
  369.     enter_mark_origin(&siScomma);
  370.     siScomma_at = make_si_ordinary(",@");
  371.     enter_mark_origin(&siScomma_at);
  372.     siScomma_dot = make_si_ordinary(",.");
  373.     enter_mark_origin(&siScomma_dot);
  374.  
  375.     Slist = make_ordinary("LIST");
  376.     enter_mark_origin(&Slist);
  377.     SlistA = make_ordinary("LIST*");
  378.     enter_mark_origin(&SlistA);
  379.     Sappend = make_ordinary("APPEND");
  380.     enter_mark_origin(&Sappend);
  381.     Snconc = make_ordinary("NCONC");
  382.     enter_mark_origin(&Snconc);
  383.  
  384.     Sapply = make_ordinary("APPLY");
  385.     enter_mark_origin(&Sapply);
  386.     Svector = make_ordinary("VECTOR");
  387.     enter_mark_origin(&Svector);
  388.  
  389.     r = standard_readtable;
  390.     r->rt.rt_self['`'].rte_chattrib = cat_terminating;
  391.     r->rt.rt_self['`'].rte_macro = make_cf(Lbackquote_reader);
  392.     r->rt.rt_self[','].rte_chattrib = cat_terminating;
  393.     r->rt.rt_self[','].rte_macro = make_cf(Lcomma_reader);
  394.  
  395.     backq_level = 0;
  396. }
  397.